home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / kcl / akcl / kcl.lha / c / num_co.c < prev    next >
C/C++ Source or Header  |  1987-06-04  |  24KB  |  1,375 lines
  1. /*
  2. (c) Copyright Taiichi Yuasa and Masami Hagiya, 1984.  All rights reserved.
  3. Copying of this file is authorized to users who have executed the true and
  4. proper "License Agreement for Kyoto Common LISP" with SIGLISP.
  5. */
  6.  
  7. /*
  8.     num_co.c
  9.     IMPLEMENTATION-DEPENDENT
  10.  
  11.     This file contains those functions
  12.     that know the representation of floating-point numbers.
  13. */    
  14.  
  15. #include "include.h"
  16. #include "num_include.h"
  17.  
  18. object plus_half, minus_half;
  19.  
  20.  
  21. #ifdef VAX
  22. /*
  23.     radix = 2
  24.  
  25.     SEEEEEEEEHHHHHHH    The redundant most significant fraction bit
  26.     HHHHHHHHHHHHHHHH    is not expressed.
  27.     LLLLLLLLLLLLLLLL
  28.     LLLLLLLLLLLLLLLL
  29. */
  30. #endif
  31. #ifdef IBMRT
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38.  
  39.  
  40. #endif
  41. #ifdef IEEEFLOAT
  42. #ifdef NS32K
  43.  
  44.  
  45.  
  46.  
  47.  
  48.  
  49.  
  50. #else
  51. /*
  52.     radix = 2
  53.  
  54.     SEEEEEEEEEEEHHHHHHHHHHHHHHHHHHHH    The redundant most
  55.     LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL    significant fraction bit
  56.                         is not expressed.
  57. */
  58. #endif
  59. #endif
  60. #ifdef MV
  61.  
  62.  
  63.  
  64.  
  65.  
  66.  
  67. #endif
  68. #ifdef S3000
  69. /*
  70.     radix = 16
  71.  
  72.     SEEEEEEEHHHHHHHHHHHHHHHHHHHHHHHH
  73.     LLLLLLLLLLLLLLLLLLLLLLLLLLLLLLLL
  74. */
  75. #endif
  76. integer_decode_double(d, hp, lp, ep, sp)
  77. double d;
  78. int *hp, *lp, *ep, *sp;
  79. {
  80.     int h, l;
  81.  
  82.     if (d == 0.0) {
  83.         *hp = *lp = 0;
  84.         *ep = 0;
  85.         *sp = 1;
  86.         return;
  87.     }
  88. #ifdef NS32K
  89.  
  90.  
  91. #else
  92.     h = *(int *)(&d);
  93.     l = *((int *)(&d) + 1);
  94. #endif
  95. #ifdef VAX
  96.     *ep = ((h >> 7) & 0xff) - 128 - 56;
  97.     h = ((h >> 15) & 0x1fffe) | (((h & 0x7f) | 0x80) << 17);
  98.     l = ((l >> 16) & 0xffff) | (l << 16);
  99. #endif
  100. #ifdef IBMRT
  101.  
  102.  
  103.  
  104. #endif
  105. #ifdef IEEEFLOAT
  106.     *ep = ((h & 0x7ff00000) >> 20) - 1022 - 53;
  107.     h = (h & 0x000fffff | 0x00100000) << 1;
  108. #endif
  109. #ifdef MV
  110.  
  111.  
  112. #endif
  113. #ifdef S3000
  114.     *ep = ((h & 0x7f000000) >> 24) - 64 - 14;
  115.     h = (h & 0x00ffffff) << 1;
  116. #endif
  117.     if (l < 0) {
  118.         h++;
  119.         l &= 0x7fffffff;
  120.     }
  121.     *hp = h;
  122.     *lp = l;
  123.     *sp = (d > 0.0 ? 1 : -1);
  124. }
  125.  
  126. #ifdef VAX
  127. /*
  128.     radix = 2
  129.  
  130.     SEEEEEEEEMMMMMMM    The redundant most significant fraction bit
  131.     MMMMMMMMMMMMMMMM    is not expressed.
  132. */
  133. #endif
  134. #ifdef IBMRT
  135.  
  136.  
  137.  
  138.  
  139.  
  140.  
  141. #endif
  142. #ifdef IEEEFLOAT
  143. /*
  144.     radix = 2
  145.  
  146.     SEEEEEEEEMMMMMMMMMMMMMMMMMMMMMMM    The redundant most
  147.                         significant fraction bit
  148.                         is not expressed.
  149. */
  150. #endif
  151. #ifdef MV
  152.  
  153.  
  154.  
  155.  
  156.  
  157. #endif
  158. #ifdef S3000
  159. /*
  160.     radix = 16
  161.  
  162.     SEEEEEEEMMMMMMMMMMMMMMMMMMMMMMMM
  163. */
  164. #endif
  165. integer_decode_float(d, mp, ep, sp)
  166. double d;
  167. int *mp, *ep, *sp;
  168. {
  169.     float f;
  170.     int m;
  171.  
  172.     f = d;
  173.     if (f == 0.0) {
  174.         *mp = 0;
  175.         *ep = 0;
  176.         *sp = 1;
  177.         return;
  178.     }
  179.     m = *(int *)(&f);
  180. #ifdef VAX
  181.     *ep = ((m >> 7) & 0xff) - 128 - 24;
  182.     *mp = ((m >> 16) & 0xffff) | (((m & 0x7f) | 0x80) << 16);
  183. #endif
  184. #ifdef IBMRT
  185.  
  186.  
  187. #endif
  188. #ifdef IEEEFLOAT
  189.     *ep = ((m & 0x7f800000) >> 23) - 126 - 24;
  190.     *mp = m & 0x007fffff | 0x00800000;
  191. #endif
  192. #ifdef MV
  193.  
  194.  
  195. #endif
  196. #ifdef S3000
  197.     *ep = ((m & 0x7f000000) >> 24) - 64 - 6;
  198.     *mp = m & 0x00ffffff;
  199. #endif
  200.     *sp = (f > 0.0 ? 1 : -1);
  201. }
  202.  
  203. int
  204. double_exponent(d)
  205. double d;
  206. {
  207.     if (d == 0.0)
  208.         return(0);
  209. #ifdef VAX
  210.     return(((*(int *)(&d) >> 7) & 0xff) - 128);
  211. #endif
  212. #ifdef IBMRT
  213.  
  214. #endif
  215. #ifdef IEEEFLOAT
  216. #ifdef NS32K
  217.  
  218. #else
  219.     return(((*(int *)(&d) & 0x7ff00000) >> 20) - 1022);
  220. #endif
  221. #endif
  222. #ifdef MV
  223.  
  224. #endif
  225. #ifdef S3000
  226.     return(((*(int *)(&d) & 0x7f000000) >> 24) - 64);
  227. #endif
  228. }
  229.  
  230. double
  231. set_exponent(d, e)
  232. double d;
  233. int e;
  234. {
  235.     double dummy;
  236.  
  237.     if (d == 0.0)
  238.         return(0.0);
  239.     *(int *)(&d)
  240. #ifdef VAX
  241.     = *(int *)(&d) & 0xffff807f | ((e + 128) << 7) & 0x7f80;
  242. #endif
  243. #ifdef IBMRT
  244.  
  245. #endif
  246. #ifdef IEEEFLOAT
  247. #ifdef NS32K
  248.  
  249. #else
  250.     = *(int *)(&d) & 0x800fffff | ((e + 1022) << 20) & 0x7ff00000;
  251. #endif
  252. #endif
  253. #ifdef MV
  254.  
  255. #endif
  256. #ifdef S3000
  257.     = *(int *)(&d) & 0x80ffffff | ((e + 64) << 24) & 0x7f000000;
  258. #endif
  259.     dummy = d*d;
  260.     return(d);
  261. }
  262.  
  263.  
  264. object
  265. double_to_integer(d)
  266. double d;
  267. {
  268.     int h, l, e, s;
  269.     object x, y;
  270.     object shift_integer();
  271.     vs_mark;
  272.  
  273.     if (d == 0.0)
  274.         return(small_fixnum(0));
  275.     integer_decode_double(d, &h, &l, &e, &s);
  276. #ifdef VAX
  277.     if (e <= -31) {
  278.         h >>= (-e) - 31;
  279. #endif
  280. #ifdef IBMRT
  281.  
  282.  
  283. #endif
  284. #ifdef IEEEFLOAT
  285.     if (e <= -31) {
  286.         e = (-e) - 31;
  287.         if (e >= 31)
  288.             return(small_fixnum(0));
  289.         h >>= e;
  290. #endif
  291. #ifdef MV
  292.  
  293.  
  294. #endif
  295. #ifdef S3000
  296.     if (e <= -8) {
  297.         h >>= 4*(-e) - 31;
  298. #endif
  299.         return(make_fixnum(s*h));
  300.     }
  301.     if (h != 0)
  302.         x = bignum2(h, l);
  303.     else
  304.         x = make_fixnum(l);
  305.     vs_push(x);
  306. #ifdef VAX
  307.     x = shift_integer(x, e);
  308. #endif
  309. #ifdef IBMRT
  310.  
  311. #endif
  312. #ifdef IEEEFLOAT
  313.     x = shift_integer(x, e);
  314. #endif
  315. #ifdef MV
  316.  
  317. #endif
  318. #ifdef S3000
  319.     x = shift_integer(x, 4*e);
  320. #endif
  321.     if (s < 0) {
  322.         vs_push(x);
  323.         x = number_negate(x);
  324.     }
  325.     vs_reset;
  326.     return(x);
  327. }
  328.  
  329. object
  330. remainder(x, y, q)
  331. object x, y, q;
  332. {
  333.     object z;
  334.  
  335.     z = number_times(q, y);
  336.     vs_push(z);
  337.     z = number_minus(x, z);
  338.     vs_pop;
  339.     return(z);
  340. }
  341.  
  342.  
  343. Lfloat()
  344. {
  345.     double    d;
  346.     int narg;
  347.     object    x;
  348.     enum type t;
  349.  
  350.     narg = vs_top - vs_base;
  351.     if (narg < 1)
  352.         too_few_arguments();
  353.     else if (narg > 2)
  354.         too_many_arguments();
  355.     if (narg == 2) {
  356.         check_type_float(&vs_base[1]);
  357.         t = type_of(vs_base[1]);
  358.     }
  359.     x = vs_base[0];
  360.     switch (type_of(x)) {
  361.     case t_fixnum:
  362.         if (narg > 1 && t == t_longfloat)
  363.             x = make_longfloat((double)(fix(x)));
  364.         else
  365.             x = make_shortfloat((shortfloat)(fix(x)));
  366.         break;
  367.  
  368.     case t_bignum:
  369.     case t_ratio:
  370.         d = number_to_double(x);
  371.         if (narg > 1 && t == t_longfloat)
  372.             x = make_longfloat(d);
  373.         else
  374.             x = make_shortfloat((shortfloat)d);
  375.         break;
  376.  
  377.     case t_shortfloat:
  378.         if (narg > 1 && t == t_longfloat)
  379.             x = make_longfloat((double)(sf(x)));
  380.         break;
  381.  
  382.     case t_longfloat:
  383.         if (narg > 1 && t == t_shortfloat)
  384.             x = make_shortfloat((shortfloat)(lf(x)));
  385.         break;
  386.  
  387.     default:
  388.         FEwrong_type_argument(TSor_rational_float, x);
  389.     }
  390.     vs_base = vs_top;
  391.     vs_push(x);
  392. }
  393.  
  394. Lnumerator()
  395. {
  396.     check_arg(1);
  397.     check_type_rational(&vs_base[0]);
  398.     if (type_of(vs_base[0]) == t_ratio)
  399.         vs_base[0] = vs_base[0]->rat.rat_num;
  400. }
  401.  
  402. Ldenominator()
  403. {
  404.     check_arg(1);
  405.     check_type_rational(&vs_base[0]);
  406.     if (type_of(vs_base[0]) == t_ratio)
  407.         vs_base[0] = vs_base[0]->rat.rat_den;
  408.     else
  409.         vs_base[0] = small_fixnum(1);
  410. }
  411.  
  412. Lfloor()
  413. {
  414.     object x, y, q, q1;
  415.     double d;
  416.     int n;
  417.     object one_minus();
  418.  
  419.     n = vs_top - vs_base;
  420.     if (n == 0)
  421.         too_few_arguments();
  422.     if (n > 1)
  423.         goto TWO_ARG;
  424.     x = vs_base[0];
  425.     switch (type_of(x)) {
  426.  
  427.     case t_fixnum:
  428.     case t_bignum:
  429.         vs_push(small_fixnum(0));
  430.         return;
  431.  
  432.     case t_ratio:
  433.         q = x;
  434.         y = small_fixnum(1);
  435.         goto RATIO;
  436.  
  437.     case t_shortfloat:
  438.         d = (double)(sf(x));
  439.         q1 = double_to_integer(d);
  440.         d -= number_to_double(q1);
  441.         if (sf(x) < 0.0 && d != 0.0) {
  442.             vs_push(q1);
  443.             q1 = one_minus(q1);
  444.             d += 1.0;
  445.         }
  446.         vs_base = vs_top;
  447.         vs_push(q1);
  448.         vs_push(make_shortfloat((shortfloat)d));
  449.         return;
  450.  
  451.     case t_longfloat:
  452.         d = lf(x);
  453.         q1 = double_to_integer(d);
  454.         d -= number_to_double(q1);
  455.         if (lf(x) < 0.0 && d != 0.0) {
  456.             vs_push(q1);
  457.             q1 = one_minus(q1);
  458.             d += 1.0;
  459.         }
  460.         vs_base = vs_top;
  461.         vs_push(q1);
  462.         vs_push(make_longfloat(d));
  463.         return;
  464.  
  465.     default:
  466.         FEwrong_type_argument(TSor_rational_float, x);
  467.     }
  468.  
  469. TWO_ARG:
  470.     if (n > 2)
  471.         too_many_arguments();
  472.     x = vs_base[0];
  473.     y = vs_base[1];
  474.     if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
  475.         (type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
  476.         vs_base = vs_top;
  477.         if (number_zerop(x)) {
  478.             vs_push(small_fixnum(0));
  479.             vs_push(small_fixnum(0));
  480.             return;
  481.         }
  482.         vs_push(Cnil);
  483.         vs_push(Cnil);
  484.         integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
  485.         if (number_minusp(x) ? number_plusp(y) : number_minusp(y)) {
  486.             if (number_zerop(vs_base[1]))
  487.                 return;
  488.             vs_base[0] = one_minus(vs_base[0]);
  489.             vs_base[1] = number_plus(vs_base[1], y);
  490.         }
  491.         return;
  492.     }
  493.     check_type_or_rational_float(&vs_base[0]);
  494.     check_type_or_rational_float(&vs_base[1]);
  495.     q = number_divide(x, y);
  496.     vs_push(q);
  497.     switch (type_of(q)) {
  498.     case t_fixnum:
  499.     case t_bignum:
  500.         vs_base = vs_top;
  501.         vs_push(q);
  502.         vs_push(small_fixnum(0));
  503.         break;
  504.     
  505.     case t_ratio:
  506.     RATIO:
  507.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  508.         if (number_minusp(q)) {
  509.             vs_push(q1);
  510.             q1 = one_minus(q1);
  511.         } else
  512.             q1 = q1;
  513.         vs_base = vs_top;
  514.         vs_push(q1);
  515.         vs_push(remainder(x, y, q1));
  516.         return;
  517.  
  518.     case t_shortfloat:
  519.     case t_longfloat:
  520.         q1 = double_to_integer(number_to_double(q));
  521.         if (number_minusp(q1) && number_compare(q, q1)) {
  522.             vs_push(q1);
  523.             q1 = one_minus(q1);
  524.         } else
  525.             q1 = q1;
  526.         vs_base = vs_top;
  527.         vs_push(q1);
  528.         vs_push(remainder(x, y, q1));
  529.         return;
  530.     }
  531. }
  532.  
  533. Lceiling()
  534. {
  535.     object x, y, q, q1;
  536.     double d;
  537.     int n;
  538.     object one_plus();
  539.  
  540.     n = vs_top - vs_base;
  541.     if (n == 0)
  542.         too_few_arguments();
  543.     if (n > 1)
  544.         goto TWO_ARG;
  545.     x = vs_base[0];
  546.     switch (type_of(x)) {
  547.  
  548.     case t_fixnum:
  549.     case t_bignum:
  550.         vs_push(small_fixnum(0));
  551.         return;
  552.  
  553.     case t_ratio:
  554.         q = x;
  555.         y = small_fixnum(1);
  556.         goto RATIO;        
  557.  
  558.     case t_shortfloat:
  559.         d = (double)(sf(x));
  560.         q1 = double_to_integer(d);
  561.         d -= number_to_double(q1);
  562.         if (sf(x) > 0.0 && d != 0.0) {
  563.             vs_push(q1);
  564.             q1 = one_plus(q1);
  565.             d -= 1.0;
  566.         }
  567.         vs_base = vs_top;
  568.         vs_push(q1);
  569.         vs_push(make_shortfloat((shortfloat)d));
  570.         return;
  571.  
  572.     case t_longfloat:
  573.         d = lf(x);
  574.         q1 = double_to_integer(d);
  575.         d -= number_to_double(q1);
  576.         if (lf(x) > 0.0 && d != 0.0) {
  577.             vs_push(q1);
  578.             q1 = one_plus(q1);
  579.             d -= 1.0;
  580.         }
  581.         vs_base = vs_top;
  582.         vs_push(q1);
  583.         vs_push(make_longfloat(d));
  584.         return;
  585.  
  586.     default:
  587.         FEwrong_type_argument(TSor_rational_float, x);
  588.     }
  589.  
  590. TWO_ARG:
  591.     if (n > 2)
  592.         too_many_arguments();
  593.     x = vs_base[0];
  594.     y = vs_base[1];
  595.     if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
  596.         (type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
  597.         vs_base = vs_top;
  598.         if (number_zerop(x)) {
  599.             vs_push(small_fixnum(0));
  600.             vs_push(small_fixnum(0));
  601.             return;
  602.         }
  603.         vs_push(Cnil);
  604.         vs_push(Cnil);
  605.         integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
  606.         if (number_plusp(x) ? number_plusp(y) : number_minusp(y)) {
  607.             if (number_zerop(vs_base[1]))
  608.                 return;
  609.             vs_base[0] = one_plus(vs_base[0]);
  610.             vs_base[1] = number_minus(vs_base[1], y);
  611.         }
  612.         return;
  613.     }
  614.     check_type_or_rational_float(&vs_base[0]);
  615.     check_type_or_rational_float(&vs_base[1]);
  616.     q = number_divide(x, y);
  617.     vs_push(q);
  618.     switch (type_of(q)) {
  619.     case t_fixnum:
  620.     case t_bignum:
  621.         vs_base = vs_top;
  622.         vs_push(q);
  623.         vs_push(small_fixnum(0));
  624.         break;
  625.     
  626.     case t_ratio:
  627.     RATIO:
  628.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  629.         if (number_plusp(q)) {
  630.             vs_push(q1);
  631.             q1 = one_plus(q1);
  632.         } else
  633.             q1 = q1;
  634.         vs_base = vs_top;
  635.         vs_push(q1);
  636.         vs_push(remainder(x, y, q1));
  637.         return;
  638.  
  639.     case t_shortfloat:
  640.     case t_longfloat:
  641.         q1 = double_to_integer(number_to_double(q));
  642.         if (number_plusp(q1) && number_compare(q, q1)) {
  643.             vs_push(q1);
  644.             q1 = one_plus(q1);
  645.         } else
  646.             q1 = q1;
  647.         vs_base = vs_top;
  648.         vs_push(q1);
  649.         vs_push(remainder(x, y, q1));
  650.         return;
  651.     }
  652. }
  653.  
  654. Ltruncate()
  655. {
  656.     object x, y, q, q1;
  657.     int n;
  658.  
  659.     n = vs_top - vs_base;
  660.     if (n == 0)
  661.         too_few_arguments();
  662.     if (n > 1)
  663.         goto TWO_ARG;
  664.     x = vs_base[0];
  665.     switch (type_of(x)) {
  666.  
  667.     case t_fixnum:
  668.     case t_bignum:
  669.         vs_push(small_fixnum(0));
  670.         return;
  671.  
  672.     case t_ratio:
  673.         q1 = integer_divide1(x->rat.rat_num, x->rat.rat_den);
  674.         vs_base = vs_top;
  675.         vs_push(q1);
  676.         vs_push(number_minus(x, q1));
  677.         return;
  678.  
  679.     case t_shortfloat:
  680.         q1 = double_to_integer((double)(sf(x)));
  681.         vs_base = vs_top;
  682.         vs_push(q1);
  683.         vs_push(number_minus(x, q1));
  684.         return;
  685.  
  686.     case t_longfloat:
  687.         q1 = double_to_integer(lf(x));
  688.         vs_base = vs_top;
  689.         vs_push(q1);
  690.         vs_push(number_minus(x, q1));
  691.         return;
  692.  
  693.     default:
  694.         FEwrong_type_argument(TSor_rational_float, x);
  695.     }
  696.  
  697. TWO_ARG:
  698.     if (n > 2)
  699.         too_many_arguments();
  700.     x = vs_base[0];
  701.     y = vs_base[1];
  702.     if ((type_of(x) == t_fixnum || type_of(x) == t_bignum) &&
  703.         (type_of(y) == t_fixnum || type_of(y) == t_bignum)) {
  704.         integer_quotient_remainder_1(x, y, &vs_base[0], &vs_base[1]);
  705.         return;
  706.     }
  707.     check_type_or_rational_float(&vs_base[0]);
  708.     check_type_or_rational_float(&vs_base[1]);
  709.     q = number_divide(x, y);
  710.     vs_push(q);
  711.     switch (type_of(q)) {
  712.     case t_fixnum:
  713.     case t_bignum:
  714.         vs_base = vs_top;
  715.         vs_push(q);
  716.         vs_push(small_fixnum(0));
  717.         break;
  718.     
  719.     case t_ratio:
  720.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  721.         vs_base = vs_top;
  722.         vs_push(q1);
  723.         vs_push(remainder(x, y, q1));
  724.         return;
  725.  
  726.     case t_shortfloat:
  727.     case t_longfloat:
  728.         q1 = double_to_integer(number_to_double(q));
  729.         vs_base = vs_top;
  730.         vs_push(q1);
  731.         vs_push(remainder(x, y, q1));
  732.         return;
  733.     }
  734. }
  735.  
  736. Lround()
  737. {
  738.     object x, y, q, q1, r;
  739.     double d;
  740.     int n, c;
  741.     object one_plus(), one_minus();
  742.  
  743.     n = vs_top - vs_base;
  744.     if (n == 0)
  745.         too_few_arguments();
  746.     if (n > 1)
  747.         goto TWO_ARG;
  748.     x = vs_base[0];
  749.     switch (type_of(x)) {
  750.  
  751.     case t_fixnum:
  752.     case t_bignum:
  753.         vs_push(small_fixnum(0));
  754.         return;
  755.  
  756.     case t_ratio:
  757.         q = x;
  758.         y = small_fixnum(1);
  759.         goto RATIO;
  760.  
  761.     case t_shortfloat:
  762.         d = (double)(sf(x));
  763.         if (d >= 0.0)
  764.             q = double_to_integer(d + 0.5);
  765.         else
  766.             q = double_to_integer(d - 0.5);
  767.         d -= number_to_double(q);
  768.         if (d == 0.5 && number_oddp(q)) {
  769.             vs_push(q);
  770.             q = one_plus(q);
  771.             d = -0.5;
  772.         }
  773.         if (d == -0.5 && number_oddp(q)) {
  774.             vs_push(q);
  775.             q = one_minus(q);
  776.             d = 0.5;
  777.         }
  778.         vs_base = vs_top;
  779.         vs_push(q);
  780.         vs_push(make_shortfloat((shortfloat)d));
  781.         return;
  782.  
  783.     case t_longfloat:
  784.         d = lf(x);
  785.         if (d >= 0.0)
  786.             q = double_to_integer(d + 0.5);
  787.         else
  788.             q = double_to_integer(d - 0.5);
  789.         d -= number_to_double(q);
  790.         if (d == 0.5 && number_oddp(q)) {
  791.             vs_push(q);
  792.             q = one_plus(q);
  793.             d = -0.5;
  794.         }
  795.         if (d == -0.5 && number_oddp(q)) {
  796.             vs_push(q);
  797.             q = one_minus(q);
  798.             d = 0.5;
  799.         }
  800.         vs_base = vs_top;
  801.         vs_push(q);
  802.         vs_push(make_longfloat(d));
  803.         return;
  804.  
  805.     default:
  806.         FEwrong_type_argument(TSor_rational_float, x);
  807.     }
  808.  
  809. TWO_ARG:
  810.     if (n > 2)
  811.         too_many_arguments();
  812.     x = vs_base[0];
  813.     y = vs_base[1];
  814.     check_type_or_rational_float(&vs_base[0]);
  815.     check_type_or_rational_float(&vs_base[1]);
  816.     q = number_divide(x, y);
  817.     vs_push(q);
  818.     switch (type_of(q)) {
  819.     case t_fixnum:
  820.     case t_bignum:
  821.         vs_base = vs_top;
  822.         vs_push(q);
  823.         vs_push(small_fixnum(0));
  824.         break;
  825.     
  826.     case t_ratio:
  827.     RATIO:
  828.         q1 = integer_divide1(q->rat.rat_num, q->rat.rat_den);
  829.         vs_push(q1);
  830.         r = number_minus(q, q1);
  831.         vs_push(r);
  832.         if ((c = number_compare(r, plus_half)) > 0 ||
  833.             (c == 0 && number_oddp(q1)))
  834.             q1 = one_plus(q1);
  835.         if ((c = number_compare(r, minus_half)) < 0 ||
  836.             (c == 0 && number_oddp(q1)))
  837.             q1 = one_minus(q1);
  838.         vs_base = vs_top;
  839.         vs_push(q1);
  840.         vs_push(remainder(x, y, q1));
  841.         return;
  842.  
  843.     case t_shortfloat:
  844.     case t_longfloat:
  845.         d = number_to_double(q);
  846.         if (d >= 0.0)
  847.             q1 = double_to_integer(d + 0.5);
  848.         else
  849.             q1 = double_to_integer(d - 0.5);
  850.         d -= number_to_double(q1);
  851.         if (d == 0.5 && number_oddp(q1)) {
  852.             vs_push(q1);
  853.             q1 = one_plus(q1);
  854.         }
  855.         if (d == -0.5 && number_oddp(q1)) {
  856.             vs_push(q1);
  857.             q1 = one_minus(q1);
  858.         }
  859.         vs_base = vs_top;
  860.         vs_push(q1);
  861.         vs_push(remainder(x, y, q1));
  862.         return;
  863.     }
  864. }
  865.  
  866. Lmod()
  867. {
  868.     check_arg(2);
  869.     Lfloor();
  870.     vs_base++;
  871. }
  872.  
  873. Lrem()
  874. {
  875.     check_arg(2);
  876.     Ltruncate();
  877.     vs_base++;
  878. }
  879.  
  880.  
  881. Ldecode_float()
  882. {
  883.     object x;
  884.     double d;
  885.     int e, s;
  886.  
  887.     check_arg(1);
  888.     check_type_float(&vs_base[0]);
  889.     x = vs_base[0];
  890.     if (type_of(x) == t_shortfloat)
  891.         d = sf(x);
  892.     else
  893.         d = lf(x);
  894.     if (d >= 0.0)
  895.         s = 1;
  896.     else {
  897.         d = -d;
  898.         s = -1;
  899.     }
  900.     e = double_exponent(d);
  901.     d = set_exponent(d, 0);
  902.     vs_top = vs_base;
  903.     if (type_of(x) == t_shortfloat) {
  904.         vs_push(make_shortfloat((shortfloat)d));
  905.         vs_push(make_fixnum(e));
  906.         vs_push(make_shortfloat((shortfloat)s));
  907.     } else {
  908.         vs_push(make_longfloat(d));
  909.         vs_push(make_fixnum(e));
  910.         vs_push(make_longfloat((double)s));
  911.     }
  912. }
  913.  
  914. Lscale_float()
  915. {
  916.     object x;
  917.     double d;
  918.     int e, k;
  919.  
  920.     check_arg(2);
  921.     check_type_float(&vs_base[0]);
  922.     x = vs_base[0];
  923.     if (type_of(vs_base[1]) == t_fixnum)
  924.         k = fix(vs_base[1]);
  925.     else
  926.         FEerror("~S is an illegal exponent.", 1, vs_base[1]);
  927.     if (type_of(x) == t_shortfloat)
  928.         d = sf(x);
  929.     else
  930.         d = lf(x);
  931.     e = double_exponent(d) + k;
  932. #ifdef VAX
  933.     if (e <= -128 || e >= 128)
  934. #endif
  935. #ifdef IBMRT
  936.  
  937. #endif
  938. #ifdef IEEEFLOAT
  939.     if (type_of(x) == t_shortfloat && (e <= -126 || e >= 130) ||
  940.         type_of(x) == t_longfloat && (e <= -1022 || e >= 1026))
  941. #endif
  942. #ifdef MV
  943.  
  944. #endif
  945. #ifdef S3000
  946.     if (e < -64 || e >= 64)
  947. #endif
  948.         FEerror("~S is an illegal exponent.", 1, vs_base[1]);
  949.     d = set_exponent(d, e);
  950.     vs_pop;
  951.     if (type_of(x) == t_shortfloat)
  952.         vs_base[0] = make_shortfloat((shortfloat)d);
  953.     else
  954.         vs_base[0] = make_longfloat(d);
  955. }
  956.  
  957. Lfloat_radix()
  958. {
  959.     check_arg(1);
  960.     check_type_float(&vs_base[0]);
  961. #ifdef VAX
  962.     vs_base[0] = small_fixnum(2);
  963. #endif
  964. #ifdef IBMRT
  965.  
  966. #endif
  967. #ifdef IEEEFLOAT
  968.     vs_base[0] = small_fixnum(2);
  969. #endif
  970. #ifdef MV
  971.  
  972. #endif
  973. #ifdef S3000
  974.     vs_base[0] = small_fixnum(16);
  975. #endif
  976. }
  977.  
  978. Lfloat_sign()
  979. {
  980.     object x;
  981.     int narg;
  982.     double d, f;
  983.  
  984.     narg = vs_top - vs_base;
  985.     if (narg < 1)
  986.         too_few_arguments();
  987.     else if (narg > 2)
  988.         too_many_arguments();
  989.     check_type_float(&vs_base[0]);
  990.     x = vs_base[0];
  991.     if (type_of(x) == t_shortfloat)
  992.         d = sf(x);
  993.     else
  994.         d = lf(x);
  995.     if (narg == 1)
  996.         f = 1.0;
  997.     else {
  998.         check_type_float(&vs_base[1]);
  999.         x = vs_base[1];
  1000.         if (type_of(x) == t_shortfloat)
  1001.             f = sf(x);
  1002.         else
  1003.             f = lf(x);
  1004.         if (f < 0.0)
  1005.             f = -f;
  1006.     }
  1007.     if (d < 0.0)
  1008.         f = -f;
  1009.     vs_top = vs_base;
  1010.     if (type_of(x) == t_shortfloat)
  1011.         vs_push(make_shortfloat((shortfloat)f));
  1012.     else
  1013.         vs_push(make_longfloat(f));
  1014. }
  1015.  
  1016. Lfloat_digits()
  1017. {
  1018.     check_arg(1);
  1019.     check_type_float(&vs_base[0]);
  1020.     if (type_of(vs_base[0]) == t_shortfloat)
  1021.         vs_base[0] = small_fixnum(6);
  1022.     else
  1023.         vs_base[0] = small_fixnum(14);
  1024. }
  1025.  
  1026. Lfloat_precision()
  1027. {
  1028.     object x;
  1029.  
  1030.     check_arg(1);
  1031.     check_type_float(&vs_base[0]);
  1032.     x = vs_base[0];
  1033.     if (type_of(x) == t_shortfloat)
  1034.         if (sf(x) == 0.0)
  1035.             vs_base[0] = small_fixnum(0);
  1036.         else
  1037.             vs_base[0] = small_fixnum(6);
  1038.     else
  1039.         if (lf(x) == 0.0)
  1040.             vs_base[0] = small_fixnum(0);
  1041.         else
  1042. #ifdef VAX
  1043.             vs_base[0] = small_fixnum(14);
  1044. #endif
  1045. #ifdef IBMRT
  1046.  
  1047. #endif
  1048. #ifdef IEEEFLOAT
  1049.             vs_base[0] = small_fixnum(13);
  1050. #endif
  1051. #ifdef MV
  1052.  
  1053. #endif
  1054. #ifdef S3000
  1055.             vs_base[0] = small_fixnum(14);
  1056. #endif
  1057. }
  1058.  
  1059. Linteger_decode_float()
  1060. {
  1061.     object x;
  1062.     int h, l, e, s;
  1063.  
  1064.     check_arg(1);
  1065.     check_type_float(&vs_base[0]);
  1066.     x = vs_base[0];
  1067.     vs_base = vs_top;
  1068.     if (type_of(x) == t_longfloat) {
  1069.         integer_decode_double(lf(x), &h, &l, &e, &s);
  1070.         if (h != 0)
  1071.             vs_push(bignum2(h, l));
  1072.         else
  1073.             vs_push(make_fixnum(l));
  1074.         vs_push(make_fixnum(e));
  1075.         vs_push(make_fixnum(s));
  1076.     } else {
  1077.         integer_decode_float((double)(sf(x)), &h, &e, &s);
  1078.         vs_push(make_fixnum(h));
  1079.         vs_push(make_fixnum(e));
  1080.         vs_push(make_fixnum(s));
  1081.     }
  1082. }
  1083.  
  1084. Lcomplex()
  1085. {
  1086.     object    x, r, i;
  1087.     int narg;
  1088.  
  1089.     narg = vs_top - vs_base;
  1090.     if (narg < 1)
  1091.         too_few_arguments();
  1092.     if (narg > 2)
  1093.         too_many_arguments();
  1094.     check_type_or_rational_float(&vs_base[0]);
  1095.     r = vs_base[0];
  1096.     if (narg == 1)
  1097.         i = small_fixnum(0);
  1098.     else {
  1099.         check_type_or_rational_float(&vs_base[1]);
  1100.         i = vs_base[1];
  1101.     }
  1102.     vs_top = vs_base;
  1103.     vs_push(make_complex(r, i));
  1104. }
  1105.  
  1106. Lrealpart()
  1107. {
  1108.     object    r, x;
  1109.  
  1110.     check_arg(1);
  1111.     check_type_number(&vs_base[0]);
  1112.     x = vs_base[0];
  1113.     if (type_of(x) == t_complex)
  1114.         vs_base[0] = x->cmp.cmp_real;
  1115. }
  1116.  
  1117. Limagpart()
  1118. {
  1119.     object x;
  1120.  
  1121.     check_arg(1);
  1122.     check_type_number(&vs_base[0]);
  1123.     x = vs_base[0];
  1124.     switch (type_of(x)) {
  1125.     case t_fixnum:
  1126.     case t_bignum:
  1127.     case t_ratio:
  1128.         vs_base[0] = small_fixnum(0);
  1129.         break;
  1130.     case t_shortfloat:
  1131.         vs_base[0] = shortfloat_zero;
  1132.         break;
  1133.     case t_longfloat:
  1134.         vs_base[0] = longfloat_zero;
  1135.         break;
  1136.     case t_complex:
  1137.         vs_base[0] = x->cmp.cmp_imag;
  1138.         break;
  1139.     }
  1140. }
  1141.  
  1142. init_num_co()
  1143. {
  1144.     int l[2];
  1145.     float smallest_float, biggest_float;
  1146.     double smallest_double, biggest_double;
  1147.     float float_epsilon, float_negative_epsilon;
  1148.     double double_epsilon, double_negative_epsilon;
  1149.  
  1150. #ifdef VAX
  1151.     l[0] = 0x80;
  1152.     l[1] = 0;
  1153.     smallest_float = *(float *)l;
  1154.     smallest_double = *(double *)l;
  1155. #endif
  1156.  
  1157. #ifdef IBMRT
  1158.  
  1159.  
  1160.  
  1161.  
  1162. #endif
  1163.  
  1164. #ifdef IEEEFLOAT
  1165. #ifdef NS32K
  1166.  
  1167.  
  1168.  
  1169.  
  1170.  
  1171. #else
  1172.     l[0] = 1;
  1173.     smallest_float = *(float *)l;
  1174.     l[0] = 0;
  1175.     l[1] = 1;
  1176.     smallest_double = *(double *)l;
  1177. #endif
  1178. #endif
  1179.  
  1180. #ifdef MV
  1181.  
  1182.  
  1183.  
  1184.  
  1185. #endif
  1186.  
  1187. #ifdef S3000
  1188.     l[0] = 0x00100000;
  1189.     l[1] = 0;
  1190.     smallest_float = *(float *)l;
  1191.     smallest_double = *(double *)l;
  1192. #endif
  1193.  
  1194. #ifdef VAX
  1195.     l[0] = 0xffff7fff;
  1196.     l[1] = 0xffffffff;
  1197.     biggest_float = *(float *)l;
  1198.     biggest_double = *(double *)l;
  1199. #endif
  1200.  
  1201. #ifdef IBMRT
  1202.  
  1203.  
  1204.  
  1205.  
  1206. #endif
  1207.  
  1208. #ifdef IEEEFLOAT
  1209. #ifdef NS32K
  1210.  
  1211.  
  1212.  
  1213.  
  1214.  
  1215. #else
  1216.     l[0] = 0x7f7fffff;
  1217.     biggest_float = *(float *)l;
  1218.     l[0] = 0x7fefffff;
  1219.     l[1] = 0xffffffff;
  1220.     biggest_double = *(double *)l;
  1221. #endif
  1222. #endif
  1223.  
  1224. #ifdef MV
  1225.  
  1226.  
  1227.  
  1228.  
  1229.  
  1230.  
  1231.  
  1232.  
  1233.  
  1234.  
  1235.  
  1236.  
  1237.  
  1238.  
  1239.  
  1240.  
  1241.  
  1242.  
  1243.  
  1244.  
  1245.  
  1246.  
  1247.  
  1248.  
  1249. #endif
  1250.  
  1251. #ifdef S3000
  1252.     l[0] = 0x7fffffff;
  1253.     l[1] = 0xffffffff;
  1254.     l[0] = 0x7fffffff;
  1255.     l[1] = 0xffffffff;
  1256.     biggest_float = *(float *)l;
  1257.     biggest_float = *(float *)l;
  1258.     biggest_float = *(float *)l;
  1259.     biggest_float = 0.0;
  1260.     biggest_float = biggest_float + 1.0;
  1261.     biggest_float = biggest_float + 2.0;
  1262.     biggest_float = *(float *)l;
  1263.     biggest_float = *(float *)l;
  1264.     strcmp("I don't like", "DATA GENERAL.");
  1265.     biggest_float = *(float *)l;
  1266.     biggest_double = *(double *)l;
  1267.     biggest_double = *(double *)l;
  1268.     biggest_double = *(double *)l;
  1269.     biggest_double = 0.0;
  1270.     biggest_double = biggest_double + 1.0;
  1271.     biggest_double = biggest_double + 2.0;
  1272.     biggest_double = *(double *)l;
  1273.     biggest_double = *(double *)l;
  1274.     strcmp("I don't like", "DATA GENERAL.");
  1275.     biggest_double = *(double *)l;
  1276. #endif
  1277.  
  1278.     for (float_epsilon = 1.0;
  1279.          (float)(1.0 + float_epsilon) != (float)1.0;
  1280.          float_epsilon /= 2.0)
  1281.         ;
  1282.     for (float_negative_epsilon = 1.0;
  1283.          (float)(1.0 - float_negative_epsilon) != (float)1.0;
  1284.          float_negative_epsilon /= 2.0)
  1285.         ;
  1286.     for (double_epsilon = 1.0;
  1287.          1.0 + double_epsilon != 1.0;
  1288.          double_epsilon /= 2.0)
  1289.         ;
  1290.     for (double_negative_epsilon = 1.0;
  1291.          1.0 - double_negative_epsilon != 1.0;
  1292.          double_negative_epsilon /= 2.0)
  1293.         ;
  1294.  
  1295.     make_constant("MOST-POSITIVE-SHORT-FLOAT",
  1296.               make_shortfloat(biggest_float));
  1297.     make_constant("LEAST-POSITIVE-SHORT-FLOAT",
  1298.               make_shortfloat(smallest_float));
  1299.     make_constant("LEAST-NEGATIVE-SHORT-FLOAT",
  1300.               make_shortfloat(-smallest_float));
  1301.     make_constant("MOST-NEGATIVE-SHORT-FLOAT",
  1302.               make_shortfloat(-biggest_float));
  1303.  
  1304.     make_constant("MOST-POSITIVE-SINGLE-FLOAT",
  1305.               make_longfloat(biggest_double));
  1306.     make_constant("LEAST-POSITIVE-SINGLE-FLOAT",
  1307.               make_longfloat(smallest_double));
  1308.     make_constant("LEAST-NEGATIVE-SINGLE-FLOAT",
  1309.               make_longfloat(-smallest_double));
  1310.     make_constant("MOST-NEGATIVE-SINGLE-FLOAT",
  1311.               make_longfloat(-biggest_double));
  1312.  
  1313.     make_constant("MOST-POSITIVE-DOUBLE-FLOAT",
  1314.               make_longfloat(biggest_double));
  1315.     make_constant("LEAST-POSITIVE-DOUBLE-FLOAT",
  1316.               make_longfloat(smallest_double));
  1317.     make_constant("LEAST-NEGATIVE-DOUBLE-FLOAT",
  1318.               make_longfloat(-smallest_double));
  1319.     make_constant("MOST-NEGATIVE-DOUBLE-FLOAT",
  1320.               make_longfloat(-biggest_double));
  1321.  
  1322.     make_constant("MOST-POSITIVE-LONG-FLOAT",
  1323.               make_longfloat(biggest_double));
  1324.     make_constant("LEAST-POSITIVE-LONG-FLOAT",
  1325.               make_longfloat(smallest_double));
  1326.     make_constant("LEAST-NEGATIVE-LONG-FLOAT",
  1327.               make_longfloat(-smallest_double));
  1328.     make_constant("MOST-NEGATIVE-LONG-FLOAT",
  1329.               make_longfloat(-biggest_double));
  1330.  
  1331.     make_constant("SHORT-FLOAT-EPSILON",
  1332.               make_shortfloat(float_epsilon));
  1333.     make_constant("SINGLE-FLOAT-EPSILON",
  1334.               make_longfloat(double_epsilon));
  1335.     make_constant("DOUBLE-FLOAT-EPSILON",
  1336.               make_longfloat(double_epsilon));
  1337.     make_constant("LONG-FLOAT-EPSILON",
  1338.               make_longfloat(double_epsilon));
  1339.  
  1340.     make_constant("SHORT-FLOAT-NEGATIVE-EPSILON",
  1341.               make_shortfloat(float_negative_epsilon));
  1342.     make_constant("SINGLE-FLOAT-NEGATIVE-EPSILON",
  1343.               make_longfloat(double_negative_epsilon));
  1344.     make_constant("DOUBLE-FLOAT-NEGATIVE-EPSILON",
  1345.               make_longfloat(double_negative_epsilon));
  1346.     make_constant("LONG-FLOAT-NEGATIVE-EPSILON",
  1347.               make_longfloat(double_negative_epsilon));
  1348.  
  1349.     plus_half = make_ratio(small_fixnum(1), small_fixnum(2));
  1350.     enter_mark_origin(&plus_half);
  1351.  
  1352.     minus_half = make_ratio(small_fixnum(-1), small_fixnum(2));
  1353.     enter_mark_origin(&minus_half);
  1354.  
  1355.     make_function("FLOAT", Lfloat);
  1356.     make_function("NUMERATOR", Lnumerator);
  1357.     make_function("DENOMINATOR", Ldenominator);
  1358.     make_function("FLOOR", Lfloor);
  1359.     make_function("CEILING", Lceiling);
  1360.     make_function("TRUNCATE", Ltruncate);
  1361.     make_function("ROUND", Lround);
  1362.     make_function("MOD", Lmod);
  1363.     make_function("REM", Lrem);
  1364.     make_function("DECODE-FLOAT", Ldecode_float);
  1365.     make_function("SCALE-FLOAT", Lscale_float);
  1366.     make_function("FLOAT-RADIX", Lfloat_radix);
  1367.     make_function("FLOAT-SIGN", Lfloat_sign);
  1368.     make_function("FLOAT-DIGITS", Lfloat_digits);
  1369.     make_function("FLOAT-PRECISION", Lfloat_precision);
  1370.     make_function("INTEGER-DECODE-FLOAT", Linteger_decode_float);
  1371.     make_function("COMPLEX", Lcomplex);
  1372.     make_function("REALPART", Lrealpart);
  1373.     make_function("IMAGPART", Limagpart);
  1374. }
  1375.